home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / Examples / rotatedemo.lsp < prev    next >
Lisp/Scheme  |  1990-10-11  |  5KB  |  131 lines
  1. #+macintosh(require "addbox" ":Examples:addbox")
  2. #+macintosh(require "addhandrotate" ":Examples:addhandrotate")
  3. #+macintosh(require ":Data:tutorial")
  4. #+(or unix amiga)(require "addbox" "Examples/addbox")
  5. #+(or unix amiga)(require "addhandrotate" "Examples/addhandrotate")
  6. #+(or unix amiga)(load-data "tutorial")
  7.  
  8. (defun sphere-rand (n &optional (dim 3))
  9.   (mapcar #'(lambda (k) 
  10.               (do ((x 
  11.                     (- (* 2 (uniform-rand k)) 1) 
  12.                     (- (* 2 (uniform-rand k)) 1)))
  13.                   ((< (sum (* x x)) 1) x))) (repeat dim n)))
  14.  
  15. (defmeth spin-proto :data-rotate (&optional axis (angle pi))
  16.   (unless axis
  17.           (setf axis (choose-item-dialog "Axis:" '("X" "Y" "Z")))
  18.           (if axis (setf axis (select '(x y z) axis)))
  19.           (send self :redraw))
  20.   (if axis
  21.       (let* ((alpha (send self :angle))
  22.              (cols (column-list 
  23.                     (let ((m (send self :transformation)))
  24.                        (if m m (identity-matrix 3)))))
  25.              (m (case axis
  26.                   (x (make-rotation (nth 1 cols) (nth 2 cols) alpha))
  27.                   (y (make-rotation (nth 0 cols) (nth 2 cols) alpha))
  28.                   (z (make-rotation (nth 0 cols) (nth 1 cols) alpha)))))
  29.         (dotimes (i (floor (/ angle alpha)))
  30.                  (send self :apply-transformation m)))))
  31.  
  32. (defmeth spin-proto :toggle-box ()
  33.   (if (not (send self :has-slot 'has-box :own t))
  34.       (send self :add-slot 'has-box))
  35.   (let ((has-box (slot-value 'has-box)))
  36.     (if (not has-box) (send self :add-box) (send self :clear-lines :draw nil))
  37.     (send self :redraw)
  38.     (setf (slot-value 'has-box) (not has-box))))
  39.  
  40. (defmeth spin-proto :rock-plot (&optional (n 10) (k 3))
  41.   (let ((a (send self :angle)))
  42.     (dotimes (i k) (send self :rotate-2 0 2 (- a)))
  43.     (dotimes (i n)
  44.              (dotimes (i (* 2 k)) (send self :rotate-2 0 2 a))
  45.              (dotimes (i (* 2 k)) (send self :rotate-2 0 2 (- a))))))
  46.  
  47. (defun add-demo-menu-items (bar)
  48.   (send (send bar :menu) :append-items 
  49.         (send dash-item-proto :new)
  50.         (send menu-item-proto :new "Toggle Box" :action 
  51.               #'(lambda () (send bar :toggle-box)))
  52.         (send menu-item-proto :new "Toggle Scaling" :action
  53.               #'(lambda ()
  54.                   (send bar :scale-type
  55.                         (if (eq (send bar :scale-type) 'fixed)
  56.                             'variable
  57.                             'fixed))))
  58.         (send menu-item-proto :new "Rotate..." :action
  59.               #'(lambda () (send bar :data-rotate)))
  60.         (send menu-item-proto :new "Rock Plot" :key #\R :action
  61.               #'(lambda () (send bar :rock-plot)))))
  62.  
  63. (defun make-bar-demo ()
  64.   (close-all-plots)
  65.   (def bar (spin-plot (let* ((x1 (* 20 (uniform-rand 40)))
  66.                              (x2 (normal-rand 40))
  67.                              (y (normal-rand 40)))
  68.                         (list x1 y x2))
  69.                       :variable-labels '("X1" "Y" "X2")
  70.                       :scale 'fixed))
  71.   (send bar :depth-cuing nil)
  72.   (send bar :redraw)
  73.   (add-demo-menu-items bar))
  74.  
  75. (defun make-abrasion-demo ()
  76.   (close-all-plots)
  77.   (def abr (spin-plot (list tensile-strength abrasion-loss hardness) 
  78.                       :variable-labels '("T" "A" "H")))
  79.   (add-demo-menu-items abr))
  80.  
  81. (defun make-spheres-demo ()
  82.   (close-all-plots)
  83.   (let ((x (sphere-rand 100)))
  84.     (def p1 (spin-plot (transpose x)))
  85.     (add-demo-menu-items p1)
  86.     (def p2 (spin-plot (transpose (mapcar 
  87.                                    #'(lambda (x) 
  88.                                        (let ((n (sqrt (sum (* x x))))) 
  89.                                          (* (+ .8 (* .2 n)) (/ x n)))) x))))
  90.     (send p2 :location 250 21) 
  91.     (add-demo-menu-items p2)))
  92.  
  93. (defun make-randu-demo ()
  94.   (close-all-plots)
  95.   #+macintosh (require ":Data:randu")
  96.   #+unix (load-data "randu")
  97.   (let ((p (spin-plot randu))) (add-demo-menu-items p))
  98.   (undef 'randu))
  99.  
  100. (defun make-diabetes-demo ()
  101.   (close-all-plots)
  102.   #+macintosh (require ":Data:diabetes")
  103.   #+unix (load-data "diabetes")
  104.   (let ((p (spin-plot (select diabetes '(0 1 2))
  105.                       :variable-labels (select dlabs '(0 1 2)))))
  106.     (add-demo-menu-items p))
  107.   (undef 'diabetes))
  108.  
  109. (setf demo-menu (send menu-proto :new "Demos"))
  110. (send demo-menu :append-items
  111.       (send menu-item-proto :new "Bar" :action
  112.             #'(lambda () (make-bar-demo)))
  113.       (send menu-item-proto :new "Abrasion" :action
  114.             #'(lambda () (make-abrasion-demo)))
  115.       (send menu-item-proto :new "Spheres" :action
  116.             #'(lambda () (make-spheres-demo)))
  117.       (send menu-item-proto :new "Randu" :action
  118.             #'(lambda () (make-randu-demo)))
  119.       (send menu-item-proto :new "Diabetes" :action
  120.             #'(lambda () (make-diabetes-demo))))
  121. (send demo-menu :install)
  122.  
  123. (defun demo (which)
  124.   (case which
  125.     (bar (make-bar-demo))
  126.     (abrasion (make-abrasion-demo))
  127.     (spheres (make-spheres-demo))
  128.     (randu (make-randu-demo))
  129.     (diabetes (make-diabetes-demo))))
  130.  
  131.